Libris Britannia 4/science library(b).zip/science library(b)/PROGRAMM/LOGO/H282.ZIP/MSWLOGO.ZIP/LOGOLIB.ZIP/DEMO

Text File | 1993-03-05 | 7.9 KB | 363 lines

to demo
ht
pu
settextsize 50
repeat 36 [fd 175 setpencolor 0 repcount*8 0 label heading bk 175 rt 10]
pd
cs
repeat 18 [pu fd 100 pd repeat 4 [fd 50 rt 90] rt 45 pu fd 5 setfloodcolor repcount*15 0 0 fill bk 5 lt 45 bk 100 rt 20]
pd
cs
setpensize [2 2]
repeat 72 [repeat 4 [fd 100 rt 90] setpencolor repcount*3 0 0 rt 5]
pu
setxy -50 -50
bitcut 100 100
cs
pu
repeat 36 [fd 150 bitpaste bk 150 rt 10]
repeat 10 [scrollx 10]
repeat 10 [scrolly 10]
repeat 10 [scrollx -10]
repeat 10 [scrolly -10]
cs
setpensize [1 1]
rose 150 30 [pu  setx xcor + 5  pd]
cs
hanoi 3
pd
cs
penpaint
spiral 91 2 10 100
cs
setpensize [1 1]
win
end

to rose :size :petalcount :function
make "ctr 0
do.while ~
   [ ~
   line :size ~
   rt 360 / :petalcount ~
   make "ctr :ctr + 1 ~
   run :function ~
   ] ~
   [:ctr < :petalcount]
end

to line :length
fd :length / 2
pu
bk :length
pd
fd :length / 2
end

to hanoi :number
;
; Towers of Hanoi
; Meyer A. Billmers
; November, 1983
;
; This procedure plays a graphic version of the Towers of Hanoi puzzle
; The argument is the number of disks in the configuration.
;
; c.f. putdisk, towercnt,towerset, hanoihlpr
;
local "from
local "to
local "other
local "datfil
;make "datfil openw "hanoi.dat
;fileprint :datfil (sentence [Hanoi of ] :number [towers Started at: ] time)
; to change the starting and ending needles, change the next three assignments
make "from 1
make "to 3
make "other 2
cs
ht
penpaint
setpensize [5 5]
; first we draw the table and the golden needles
setpencolor 255 0 0
pu
setxy -350 -100
pd
setxy 350 -100
pu
setx -240
pd
fd 250
pu
setxy -15 -100
pd
fd 250
pu
setxy 210 -100
pd
fd 250
make "tower1 0
make "tower2 0
make "tower3 0
; draw the initial stack of disks. note that putdisk draws the
; "fixed up" towers.
repeat :number ~
   [~
   putdisk :from :number - repcount + 1 "final ~
   ifelse :from = 1 ~
      [make "tower1 :tower1 + 1] ~
      [ifelse :from = 2 ~
         [make "tower2 :tower2 + 1] ~
         [make "tower3 :tower3 + 1] ~
      ] ~
   ]
hanoihlpr :number :from :to :other
; fileprint :datfil (sentence [Hanoi Ended at: ] time)
; close :datfil
end

to hanoihlpr :number :from :to :other
;
; Called by HANOI. Contains the actual recursive Towers of Hanoi algorithm
;
local "tcf
local "tct
if equalp :number 0 [stop]
hanoihlpr :number-1 :from :other :to
make "tcf towercnt :from
make "tct towercnt :to
towerset :from :tcf - 1
putdisk :from :number "temp
putdisk :to :number "temp
putdisk :from :number "erase
putdisk :to :number "final
towerset :to :tct + 1
hanoihlpr :number-1 :other :to :from
end

to putdisk :tnum :dnum :state
;
; Called by HANOI to put a disk on a tower.
; first arg. is number of tower (1,2 or 3)
; second arg. is number of disk to draw (1 is smallest)
; third arg. is "final, "temp, or "erase depending on whether
;   disk is drawn in final state, in temporary state to indicate
;   motion, or is being erased (removed from this tower)
; Note that this procedure re-draws the tower correctly.
;
local "tc
local "halfsize
make "tc towercnt :tnum
make "halfsize sum 20 product :dnum 10
pu
ifelse :tnum = 1 ~
   [setxy "-240 "-100] ~
   [ ~
   ifelse :tnum = 2 ~
      [setxy "-15 "-100] ~
      [setxy 210 "-100] ~
   ]
pe
fd product 30 :tc
pu
setxy xcor - :halfsize ycor
pd
penpaint
ifelse :state = "final ~
   [setpencolor 0 255 0] ~
   [ ~
   ifelse :state = "temp ~
      [setpencolor 0 0 255] ~
      [pe] ~
   ]
fd 30
rt 90
fd product :halfsize 2
rt 90
fd 30
rt 90
pu
fd :halfsize
rt 90
setpencolor 255 0 0
ifelse :state = "erase ~
   [ ~
   pd ~
   penpaint ~
   fd 30 ~
   ] ~
   [ ~
   pe ~
   fd 30 ~
   ]
end

to towercnt :tn
;
; Called by HANOI. Returns the current number of disks on tower :tn,
; as stored in the globals tower1, tower2, and tower3.
;
ifelse :tn = 1 ~
   [output :tower1] ~
   [ ~
   ifelse :tn = 2 ~
      [output :tower2] ~
      [output :tower3] ~
   ]
end

to towerset :tn :value
;
; Called by HANOI. Sets the current number of disks on tower :tn,
; as stored in the globals tower1, tower2, and tower3.
;
ifelse :tn = 1 ~
   [make "tower1 :value] ~
   [ ~
   ifelse :tn = 2 ~
      [make "tower2 :value] ~
      [make "tower3 :value] ~
   ]
end

to spiral :angle :repeat :incr :segs
;;
;; Spirals, by Meyer A. Billmers
;;
;; This procedure makes pretty spirals. I suggest you first do a
;; hideturtle so the drawing will proceed at a reasonable rate.
;;
;; angle   is the amount of turn at each piece,
;; repeat  is the number of turns before the distance is incremented, and
;; incr    is the amount of distance increment.
;;
;; Suggested fun spirals:
;;     spiral 90 2 10
;;     spiral 91 2 10
;;     spiral 60 3 10
;;     spiral 61 3 10
;;     spiral 179 2 5
;;     spiral 20 10 4
;;
make "len :incr
make "ctr 0
repeat :segs ~
  [ ~
  fd :len ~
  rt :angle ~
  make "ctr :ctr + 1 ~
  if :ctr = :repeat ~
     [ ~
     make "ctr 0 ~
     make "len :len + :incr ~
     ] ~
  ]
end

to drawthing
setpencolor scrollbarget "s1 scrollbarget "s2 scrollbarget "s3
repeat scrollbarget "s4~
  [~
  run comboboxgettext "c1~
  if equalp "HEXAGON listboxgetselect "l1 [repeat 6 [fd 100 rt 60]]~
  if equalp "SQUARE listboxgetselect "l1 [repeat 4 [fd 100 rt 90]]~
  if equalp "TRIANGLE listboxgetselect "l1 [repeat 3 [fd 100 rt 120]]~
  run comboboxgettext "c2~
  ]
end

to myblue
staticupdate "st13 sentence [Blue] scrollbarget "s3
end

to myend
dialogdelete "d1
end

to mygreen
staticupdate "st12 sentence [Grn] scrollbarget "s2
end

to mynil
end

to myred
staticupdate "st11 sentence [Red] scrollbarget "s1
end

to myrepeat
staticupdate "st14 sentence [Repeat Count] scrollbarget "s4
end

to mystatic
staticupdate "st14 sentence [Repeat Count] scrollbarget "s4
end

to win
make "cmw 75
make "cmh 30
make "sth 12
make "lsw :cmw
make "lsh 20
make "scw 10
make "sch 40
make "btw 50
make "bth 12
make "gapx 6
make "gapy 6
make "mary 2
make "wnx 180
make "wny 120
make "wnx2 :wnx / 2
make "wny2 :wny / 2
make "wnx3 :wnx / 3
make "wny3 :wny / 3
make "wnx6 :wnx / 6
make "wny6 :wny / 6
make "st2w 30
make "row2 :wny3+:gapy
make "row3 :wny3*2-:gapy/2

dialogcreate "main "d1 [This is a Demo Windows Application] 0 0 :wnx+:gapy :wny+:gapy

staticcreate "d1 "st2 [Select Pre-Command] :gapx :mary :cmw :sth
comboboxcreate "d1 "c1 :gapx :sth+:mary :cmw :cmh
comboboxaddstring "c1 [PU FD 50 PD]
comboboxaddstring "c1 [PU FD 100 PD]
comboboxaddstring "c1 [PU FD REPCOUNT PD]

staticcreate "d1 "st3 [Select Post-Command] :wnx2+:gapx :mary :cmw :sth
comboboxcreate "d1 "c2 :wnx2+:gapx :sth+:mary :cmw :cmh
comboboxaddstring "c2 [PU BK 50 PD RT 2]
comboboxaddstring "c2 [PU BK 100 PD RT 5]
comboboxaddstring "c2 [PU BK REPCOUNT PD RT 5]
comboboxsettext "c2 [RT 5]

staticcreate "d1 "st4 [Select Shape] :gapx :row2 :lsw :sth
listboxcreate "d1 "l1 :gapx :row2+:sth+1 :lsw :lsh
listboxaddstring "l1 "SQUARE
listboxaddstring "l1 "TRIANGLE
listboxaddstring "l1 "HEXAGON

staticcreate "d1 "st11 "Red :wnx6*3+:gapx :row2 :st2w :sth
scrollbarcreate "d1 "s1 :wnx6*3+:gapx :row2+:sth :scw :sch [myred]
scrollbarset "s1 1 255 125 myred

staticcreate "d1 "st12 "Grn :wnx6*4+:gapx :row2 :st2w :sth
scrollbarcreate "d1 "s2 :wnx6*4+:gapx :row2+:sth :scw :sch [mygreen]
scrollbarset "s2 1 255 125 mygreen

staticcreate "d1 "st13 "Blue :wnx6*5+:gapx :row2 :st2w :sth
scrollbarcreate "d1 "s3 :wnx6*5+:gapx :row2+:sth :scw :sch [myblue]
scrollbarset "s3 1 255 125 myblue

staticcreate "d1 "st14 [Repeat Count] :gapx :row3 :sch*2 :sth
scrollbarcreate "d1 "s4 :gapx :row3+:sth :sch*2 :scw [myrepeat]
scrollbarset "s4 1 360 72 myrepeat

buttoncreate "d1 "b1 "END :gapx :wny-:bth-:gapy :btw :bth [myend]
buttoncreate "d1 "b3 "CLEAR :wnx2-:btw/2 :wny-:bth-:gapy :btw :bth [cs]
buttoncreate "d1 "b2 "DRAW :wnx-:btw-:gapx :wny-:bth-:gapy :btw :bth [drawthing]
end